home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / jackal1a.lha / jacal / builtin.scm < prev    next >
Encoding:
Text File  |  1992-12-24  |  17.5 KB  |  622 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1989, 1990, 1991, 1992 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;;; First, what case are symbols in?  Determine the standard case:
  6. (define char-standard-case
  7.   (cond ((not (string=? (symbol->string 'a) (symbol->string 'A)))
  8.      char-downcase)
  9.     ((string=? (symbol->string 'a) "A")
  10.      char-upcase)
  11.     ((string=? (symbol->string 'A) "a")
  12.      char-downcase)
  13.     (else
  14.      char-downcase)))
  15. (define (string-standard-case s)
  16.   (set! s (string-copy s))
  17.   (do ((i 0 (+ 1 i))
  18.        (sl (string-length s)))
  19.       ((>= i sl) s)
  20.       (string-set! s i (char-standard-case (string-ref s i)))))
  21.  
  22. ;;;Predefined Variables and Constants
  23. (define newlabelstr (string-standard-case "E0"))
  24. (define newlabelsym (string->symbol newlabelstr))
  25. (define newextstr (string-standard-case "EXT_0"))
  26.  
  27. (define expl_t (var->expl (sexp->var 't)))
  28. (define _@ (string->var ":@"))
  29. (define _@-pri (+ -1 char-code-limit))
  30. (var_set-pri! _@ _@-pri)
  31. (define (_@? v) (or (eq? v _@) (= (var_pri v) _@-pri)))
  32. (define d@ (var_differential _@)) ;used only in total-differential in norm.scm
  33. (var_set-pri! d@ (+ -2 char-code-limit))
  34. (define _@1 (string->var "@1"))
  35. (define _@2 (string->var "@2"))
  36. (define _@3 (string->var "@3"))
  37.  
  38. (define __@ (string->var "::@"))
  39. (define _@1+@2 (list _@2 (list _@1 0 1) 1))
  40. (define _@1-@2 (list _@2 (list _@1 0 1) -1))
  41. (define _-@1 (list _@1 0 -1))
  42. (define _@1*@2 (list _@2 0 (list _@1 0 1)))
  43. (define _@1/@2 (list _@ (list _@1 0 1) (list _@2 0 -1)))
  44. (define _@1=@2 (list _@= _@2 (list _@1 0 -1) 1))
  45. (define cidentity (list _@1 0 1))
  46.  
  47. ;;; canoncial functions for vect.scm
  48. (define _@1-@2*@3 (list _@3 (list _@1 0 1) (list _@2 0 -1)))
  49. (define _-@1/@2 (make-rat (list _@1 0 -1) (list _@2 0 1)))
  50. (define _@1*@2+@3 (list _@3 (list _@2 0 (list _@1 0 1)) 1))
  51.  
  52. ;;; set up initial radical and extension
  53. (define %sqrt1 (defext (sexp->var '%sqrt1) (list _@ 1 0 -1)))
  54. (var_set-pri! %sqrt1 5)
  55. (define %i (defext (sexp->var '%i) (list _@ -1 0 -1)))
  56. (var_set-pri! %i 5)
  57. (define radical-defs (list (extrule %i) (extrule %sqrt1)))
  58. (define _+/-@1 (list _@1 0 (list %sqrt1 0 1)))
  59. (define _-/+@1 (list _@1 0 (list %sqrt1 0 -1)))
  60. (define _@1+/-@2 (list _@2 (list _@1 0 1) (list %sqrt1 0 1)))
  61. (define _@1-/+@2 (list _@2 (list _@1 0 1) (list %sqrt1 0 -1)))
  62.  
  63. ;;; This rule can not be entered from user level.
  64. (define %inftsl (defext (sexp->var '%inftsl) (list _@ 0 0 1)))
  65.  
  66. (define novalue (var->expl (sexp->var '?)))
  67. (define (novalue? x) (equal? novalue x))
  68. (define % novalue)
  69.  
  70. (define *flags* (make-hash-table 5))
  71. (define flag-associator (hash-associator eq?))
  72. (define flag-inquirer (hash-inquirer eq?))
  73.  
  74. (define (defflag name setter getter)
  75.   (flag-associator *flags* name (cons setter getter))
  76.   name)
  77.  
  78. (define flag:setter car)
  79. (define flag:getter cdr)
  80.  
  81. (define (flag-set name . values)
  82.   (let ((flag (flag-inquirer *flags* name)))
  83.     (cond ((not flag) (math:warn "flag" name "is not defined") novalue)
  84.       ((flag:setter flag) (apply (flag:setter flag) flag values) novalue)
  85.       (else (math:warn "flag" name "can not be set") novalue))))
  86.  
  87. (define (flag-get name . rest)
  88.   (let ((flag (flag-inquirer *flags* name)))
  89.     (cond ((not flag) (math:warn "flag" name "is not defined") novalue)
  90.       ((flag:getter flag) (apply (flag:getter flag) flag rest))
  91.       (else (math:warn "flag" name "can not be read") novalue))))
  92.  
  93. (defflag 'ingrammar
  94.   (lambda (f v)
  95.     (define name (var->sexp (explicit->var v)))
  96.     (cond ((get-grammar name)
  97.        (set! *input-grammar* (get-grammar name)))
  98.       (else
  99.        (math:warn "grammar" name "not known"))))
  100.   (lambda (f) (var->expl (sexp->var (grammar-name *input-grammar*)))))
  101.  
  102. (defflag 'outgrammar
  103.   (lambda (f v)
  104.     (define name (var->sexp (explicit->var v)))
  105.     (cond ((get-grammar name)
  106.        (set! *output-grammar* (get-grammar name)))
  107.       (else
  108.        (math:warn "grammar" name "not known"))))
  109.   (lambda (f) (var->expl (sexp->var (grammar-name *output-grammar*)))))
  110.  
  111. (defflag 'echogrammar
  112.   (lambda (f v)
  113.     (define name (var->sexp (explicit->var v)))
  114.     (cond ((get-grammar name)
  115.        (set! *echo-grammar* (get-grammar name)))
  116.       (else
  117.        (math:warn "grammar" name "not known"))))
  118.   (lambda (f) (var->expl (sexp->var (grammar-name *echo-grammar*)))))
  119.  
  120. (defflag 'grammars
  121.   #f
  122.   (lambda (f)
  123.     (map (lambda (p) (var->expl (sexp->var (car p)))) *grammars*)))
  124.  
  125. (define (set-boolean v)
  126.   (define val (var->sexp (explicit->var v)))
  127.   (case val
  128.     ((off 0 false) #f)
  129.     ((on 1 true) #t)
  130.     (else (math-error "expected boolean" v))))
  131.  
  132. (define (show-boolean v)
  133.   (var->expl (string->var (if v "on" "off"))))
  134.  
  135. (define horner #f)
  136. (defflag 'horner
  137.   (lambda (f v) (set! horner (set-boolean v)))
  138.   (lambda (f) (show-boolean horner)))
  139.  
  140. (defflag 'trace
  141.   (lambda (f v) (set! math_trace (set-boolean v)))
  142.   (lambda (f) (show-boolean math_trace)))
  143.  
  144. (defflag 'debug
  145.   (lambda (f v) (set! math_debug (set-boolean v)))
  146.   (lambda (f) (show-boolean math_debug)))
  147.  
  148. (defflag 'version
  149.   #f
  150.   (lambda (f)
  151.     (var->expl (string->var *jacal-version*))))
  152.  
  153. (defflag 'all
  154.   #f
  155.   (lambda (f)
  156.     (block-write-strings
  157.      (sort! (map symbol->string (map car (apply append (vector->list *flags*))))
  158.         string>?))
  159.     novalue))
  160.  
  161. (defflag 'prompt
  162.   (lambda (f v)
  163.     (set! newlabelstr (var->string (explicit->var v)))
  164.     (set! newlabelsym (string->symbol newlabelstr))
  165.     novalue)
  166.   (lambda (f) (var->expl (string->var newlabelstr))))
  167.  
  168. (defflag 'priority
  169.   (lambda (f v p)
  170.     (math-assert (and (number? p) (< 0 p lambda-var-pri)))
  171.     (var_set-pri! (explicit->var v) p))
  172.   (lambda args
  173.     (if (null? (cdr args))
  174.     (let ((l (apply append (map (lambda (l) (map cdr l))
  175.                     (vector->list var-tab)))))
  176.       (block-write-strings (map object->string
  177.                     (map var->sexp (sort! l var_>))))
  178.       novalue)
  179.     (var_pri (explicit->var (cadr args))))))
  180.  
  181. ;(define transcript-name #f)
  182. ;(defflag 'transcript
  183. ;  (lambda (f v)
  184. ;    (define file (and v (not (null? v)) (var->string (explicit->var v))))
  185. ;    (if v (transcript-on file) (transcript-off))
  186. ;    (set! transcript-name file))
  187. ;  (lambda (f) (if transcript-name
  188. ;          (var->expl (string->var transcript-name))
  189. ;          '#())))
  190.  
  191. ;;;; Built in functions
  192. (defbltn 'set
  193.   (lambda (name . values)
  194.     (apply flag-set (var->sexp (explicit->var name)) values))
  195.   "Set options."
  196.   '(set outgrammar scheme))
  197.  
  198. (defbltn 'show
  199.   (lambda (name . rest) (apply flag-get
  200.                    (var->sexp (explicit->var name))
  201.                    rest))
  202.   "Show options."
  203.   '(show outgrammar))
  204.  
  205. (defbltn 'commands
  206.   (lambda ()
  207.     (block-write-strings
  208.      (sort! (map object->string
  209.          (map car (apply append (vector->list infodefs))))
  210.         string>?))
  211.     novalue))
  212.  
  213. (defbltn '%
  214.   (lambda 1D %)
  215.   "Last expression")
  216.  
  217. (defbltn 'describe
  218.   (lambda (x)
  219.     (let ((doclist (hassq (var->sexp (explicit->var x)) infodefs)))
  220.       (for-each (lambda (i)
  221.           (cond ((string? i) (display i))
  222.             ((sexp? i)
  223.              (write-sexp i *output-grammar*))
  224.             (else (eval-error "bad info entry")))
  225.           (newline))
  226.         (if doclist (cdr doclist) '()))
  227.       novalue)))
  228.  
  229. (defbltn 'example
  230.   (lambda (x)
  231.     (let ((info (hassq (var->sexp (explicit->var x)) infodefs)))
  232.       (do ((info (if info (cddr info) '()) (cdr info)))
  233.       ((or (null? info) (not (string? (car info))))
  234.        (cond ((null? info) 'no_example)
  235.          (else (write-sexp (car info) *input-grammar*)
  236.                (newline)
  237.                (sexp->math (car info)))))))))
  238.  
  239. (define terms
  240.   (let ((my-vicinity (program-vicinity)))
  241.     (lambda ()
  242.       (call-with-input-file
  243.       (in-vicinity my-vicinity "COPYING")
  244.     (lambda (infile)
  245.       (do ((c (read-char infile) (read-char infile)))
  246.           ((eof-object? c) novalue)
  247.         (display c)))))))
  248. (defbltn 'terms terms)
  249.  
  250. (defbltn 'Differential
  251.   (lambda (obj) (total-differential obj)))
  252.  
  253. (defbltn 'negate
  254.   (lambda (obj) (app* _-@1 obj))
  255.   "Unary negation."
  256.   '(negate a)
  257.   '(* -1 a))
  258.  
  259. (defbltn 'u+/-
  260.   (lambda (obj) (app* _+/-@1 obj)))
  261.  
  262. (defbltn 'u-/+
  263.   (lambda (obj) (app* _-/+@1 obj)))
  264.  
  265. (defbltn '^                ;need to do expt also
  266.   (lambda (x exp)
  267.     (if (and (expl? x) (number? exp))
  268.     (poly_^ x (normalize exp))
  269.     (^ (expr x) exp)))
  270.   "Exponentiation."
  271.   '(^ (+ a 1) 2)
  272.   '(+ 1 a (^ a 2)))
  273.  
  274. (defbltn '^^                ;need to do ncexpt also
  275.   (lambda (a pow) (ncexpt (exprs a) (normalize pow)))
  276.   "Non-commutative Exponentiation.  For vectors, this is repeated dot
  277. product."
  278.   '(^^ #(a b) 2)
  279.   '(+ (^ a 2) (^ b 2))
  280.   "For matrices, this is repeated matrix multiplication.  If n is
  281. negative, the inverse of the matrix is raised to -n."
  282.   '(^^ #(#(a b) #(c d)) 2)
  283.   "For single-valued functions of one variable, This is the
  284. composition of the function with itself n times.  If n is negative,
  285. the inverse of the function is raised to -n."
  286.   '(^^ (lambda #(x) (+ 1 (* 2 x))) -2))
  287.  
  288. (defbltn '*
  289.   (lambda args (reduce (lambda (x y)
  290.              (if (and (expl? x) (expl? y))
  291.                  (poly_* x y)
  292.                  (app* _@1*@2 x y)))
  293.                args))
  294.   "Multiplication, times."
  295.   '(* a 7)
  296.   '(* 7 a))
  297.  
  298. (defbltn '+
  299.   (lambda args (reduce (lambda (x y)
  300.              (if (and (expl? x) (expl? y))
  301.                  (poly_+ x y)
  302.                  (app* _@1+@2 x y)))
  303.                args))
  304.   "Addition, plus."
  305.   '(+ a b))
  306.  
  307. (defbltn '-
  308.   (lambda args (reduce (lambda (x y)
  309.              (if (and (expl? x) (expl? y))
  310.                  (poly_- x y)
  311.                  (app* _@1-@2 x y)))
  312.                args))
  313.   "Subtraction, minus."
  314.   '(- a 9))
  315.  
  316. (defbltn 'b+/-
  317.   (lambda args (reduce (lambda (x y) (app* _@1+/-@2 x y)) args)))
  318.  
  319. (defbltn 'b-/+
  320.   (lambda args (reduce (lambda (x y) (app* _@1-/+@2 x y)) args)))
  321.  
  322. (defbltn '/
  323.   (lambda args (reduce (lambda (x y) (app* _@1/@2 x y)) args))
  324.   "Quotient, division, divide, over."
  325.   '(/ a b))
  326.  
  327. (defbltn 'bunch
  328.   (lambda args args)
  329.   "bunch, vector, list."
  330.   '(bunch a b c)
  331.   '#(a b c))
  332.  
  333. (defbltn 'rapply
  334.   (lambda args (apply rapply args))
  335.   "subscripted reference"
  336.   '(rapply #(a b) 2)
  337.   'b)
  338.  
  339. (defbltn 'or
  340.   (lambda args
  341.     (poleqn->licit (reduce poly_* (map licit->poleqn args))))
  342.   "union, multiple value.  Or of two equations returns an equation
  343. with either condition true."
  344.   '(or (= a b) (= a c))
  345.   '(= 0 (- (^ a 2) (* b c)))
  346.   "Or of two values yields a multiple value, such as +/-x"
  347.   '(or x (negate x))
  348.   '(+/- x)
  349.   "Or of an equation and a value will yield the value.")
  350.  
  351. (defbltn '=
  352.   (lambda (x y) (app* _@1=@2 x y))
  353.   "equals, equality.  This expresses a relation between variables and
  354. numbers"
  355.   '(= a (^ b 2))
  356.   '(= 0 (- a (^ b 2)))
  357.   "it does not conote value assignment")
  358.  
  359. (defbltn 'qed
  360.   (lambda ()
  361.     (cleanup-handlers!)
  362.     (math_exit #t))
  363.   "qed, bye, exit.  This leaves the math system")
  364.  
  365. (defbltn 'quit
  366.   (lambda ()
  367.     (cleanup-handlers!)
  368.     (quit))
  369.   "quit.  This leaves the math system and scheme")
  370.  
  371. ;;;; User callable functions
  372.  
  373. (defbltn 'listofvars
  374.   (lambda (exp) (map var->expl (remove-if (lambda (x) (eq? x _@))
  375.                       (alg_vars exp))))
  376.   "This returns a list of variables occuring in the argument"
  377.   '(listofvars (+ a (/ b c))))
  378.  
  379. (defbltn 'coeff
  380.   (lambda (p var . optional)
  381.     (let ((ord (if (null? optional) 1 (car optional))))
  382.       (poly_coeff p (explicit->var var) (plicit->integer ord))))
  383.   "coeff, coefficient.  Returns the coefficient of (optional 1) power
  384. of var in poly")
  385.  
  386. (defbltn 'num
  387.   (lambda (exp) (num (expr_normalize exp)))
  388.   "num, numerator, top.  The numerator of a rational expression.")
  389.  
  390. (defbltn 'denom
  391.   (lambda (exp) (denom (expr_normalize exp)))
  392.   "denom, denominator, bottom.  The denominator of a rational
  393. expression.") 
  394.  
  395. (defbltn 'divide
  396.   (lambda (dividend divisor . vars)
  397.     (set! dividend (licit->polxpr dividend))
  398.     (set! divisor (licit->polxpr divisor))
  399.     (poly_pdiv dividend divisor (if (null? vars)
  400.                     (if (number? divisor)
  401.                     (if (number? dividend) 0
  402.                         (car dividend))
  403.                     (car divisor))
  404.                     (explicit->var (car vars)))))
  405.   "divide.  A bunch of the quotient and remainder.")
  406.  
  407. (defbltn 'content
  408.   (lambda (poly var)
  409.     (let* ((var (explicit->var var))
  410.        (poly (promote var (licit->polxpr poly)))
  411.        (cont (apply poly_gcd* (cdr poly))))
  412.       (list cont (poly_/ poly cont))))
  413.   "Returns a list of content and primitive part of a polynomial with
  414. respect to the variable.  The content is the GCD of the coefficients
  415. of the polynomial in the variable.  The primitive part is poly divided
  416. by the content"
  417.   '(content (+ (* 2 x y) (* 4 (^ x 2) (^ y 2))) y)
  418.   '#((* x y) (+ y (* 2 x (^ y 2)))))
  419.  
  420. ;;; This is user callable GCD.
  421. (defbltn 'gcd
  422.   (lambda args
  423.     (if (null? args) 0
  424.     (reduce poly_gcd (map licit->polxpr args))))
  425.   "gcd, greatest common divisor.  The greatest common divisor of
  426. polynomial expressions.")
  427.  
  428. (defbltn 'mod
  429.   (lambda (licit polxpr)
  430.     (poleqn->licit (alg_mod (licit->poleqn licit) (licit->polxpr polxpr))))
  431.   "the first argument modulo the second argument")
  432.  
  433. ;;; This is user callable RESULTANT.  It always operates on
  434. ;;; polynomials and does not know about extensions etc.
  435. (defbltn 'resultant
  436.   (lambda (a b v)
  437.     (let ((res (poly_resultant
  438.         (licit->polxpr a)
  439.         (licit->polxpr b)
  440.         (explicit->var v))))
  441.       res))
  442.   "resultant.  The result of eliminating a variable between 2
  443. equations (or polynomials).") 
  444.  
  445. (defbltn 'sylvester
  446.   (lambda (p1 p2 var)
  447.     (sylvester (licit->polxpr p1)
  448.            (licit->polxpr p2)
  449.            (explicit->var var)))
  450.   "sylvester.  Matrix whose determinant is the resultant of 2
  451. equations (or polynomials).")
  452.  
  453. (defbltn 'poly_discriminant
  454.   (lambda (poly var)
  455.     (set! poly (licit->polxpr poly))
  456.     (set! poly (poly_/ poly (if (> (leading-number poly) 0)
  457.                 (poly_num-cont poly)
  458.                 (- (poly_num-cont poly)))))
  459.     (let* ((v (explicit->var var))
  460.        (deg (poly_degree poly v)))
  461.       (if (> deg 1)
  462.       (poly_* (quotient (* deg (- deg 1)) 2)
  463.           (poly_resultant (poly_diff poly v) poly v))
  464.       0)))
  465.   "discriminant of a polynomial.  the square of the product of the
  466. differences of all pairs of roots."
  467.   '(poly_discriminant (* (- x a) (- x b) (- x c)) x))
  468.  
  469. (defbltn 'eliminate
  470.   (lambda (eqns vars)
  471.     (poleqns->licits (eliminate (licits->poleqns eqns) (variables vars))))
  472.   "eliminate.  An equation or set of equations with vars eliminated")
  473.  
  474. (defbltn 'factor
  475.   (lambda (poly)
  476.     (let ((e (licit->polxpr poly)))
  477.       (cond ((number? e) (require 'prime) ;autoload from SLIB
  478.              (sort! (factor e) <))
  479.         (else (poly_factorq e))))))
  480.  
  481. (defbltn 'matrix
  482.   (lambda args (apply matrix args))
  483.   "matrix.  makes a copy of a matrix")
  484.  
  485. (defbltn 'genmatrix
  486.   (lambda (fun i2 j2 . i1j1)
  487.     (let ((i1 1) (j1 1))
  488.       (cond ((null? i1j1))
  489.         ((begin (set! i1 (car i1j1))
  490.             (set! i1j1 (cdr i1j1))
  491.             (set! j1 i1)
  492.             (null? i1j1)))
  493.         ((begin (set! j1 (car i1j1))
  494.             (set! i1j1 (cdr i1j1))
  495.             (null? i1j1)))
  496.         (else (math-error "Too many arguments")))
  497.       (mtrx_genmatrix
  498.        fun 
  499.        (plicit->integer i2)
  500.        (plicit->integer j2)
  501.        (plicit->integer i1)
  502.        (plicit->integer j1))))
  503.   "genmatrix.  A matrix whose entries are the function applied to its indices")
  504.  
  505. (defbltn 'ident
  506.   (lambda (n) (mtrx_scalarmatrix n 1))
  507.   "ident, identity matrix.  A square matrix of 0s except the diagonal
  508. entries are 1")
  509.  
  510. (defbltn 'scalarmatrix
  511.   (lambda (n x) (mtrx_scalarmatrix (plicit->integer n) x))
  512.   "scalarmatrix, diagonal matrix.  A square matrix of 0s except the
  513. diagonal entries = argument")
  514.  
  515. (defbltn 'diagmatrix
  516.   (lambda args (mtrx_diagmatrix args))
  517.   "diagmatrix takes as input a list of algebraic values and returns
  518. a diagonal matrix whose diagonal entries are the elements of that
  519. list.")
  520.  
  521. (defbltn 'determinant
  522.   (lambda (m) (determinant m))
  523.   "determinant.  The determinant of a square matrix")
  524.  
  525. (defbltn 'crossproduct
  526.   (lambda (x y) (crossproduct x y))
  527.   "crossproduct.  Crossproduct of 2 vectors")
  528.  
  529. (defbltn 'dotproduct
  530.   (lambda (x y) (dotproduct x y))
  531.   "dotproduct.  dotproduct of 2 vectors.")
  532.  
  533. (defbltn 'ncmult
  534.   (lambda (x y) (ncmult x y))
  535.   "ncmult.  non-commutative matrix multiplication of 2 vectors.")
  536.  
  537. (defbltn 'row
  538.   (lambda (m i)
  539.     (if (matrix? m)
  540.     (list-ref m (+ -1 (plicit->integer i)))
  541.       (math-error "Row of non-matrix?: " M)))
  542.   "Row.  row of a matrix")
  543.  
  544. (defbltn 'col
  545.   (lambda (m i)
  546.     (cond ((matrix? m)
  547.        (map (lambda (row)
  548.           (list (list-ref row (+ -1 (plicit->integer i)))))
  549.         m))
  550.       ((bunch? m) (list-ref m (plicit->integer i)))
  551.       (else (math-error "Column of non-matrix?: " M))))
  552.   "column.  column of a matrix")
  553.  
  554. (defbltn 'minor
  555.   (lambda (m i j)
  556.     (mtrx_minor m (plicit->integer i) (plicit->integer j)))
  557.   "minor.  minor of a matrix")
  558.  
  559. (defbltn 'transpose
  560.   (lambda (m) (transpose m))
  561.   "transpose.  transpose of a matrix")
  562.  
  563. (defbltn 'finv
  564.   (lambda (f)
  565.     (fcinverse f)))
  566.  
  567. (defbltn 'load
  568.   (lambda (file)
  569.     (load (var->string (explicit->var file)))
  570.     file))
  571.  
  572. (defbltn 'batch
  573.   (lambda (file)
  574.     (batch (var->string (explicit->var file)))))
  575.  
  576. (define wna "Wrong number of args to ")
  577.  
  578. (defbltn 'transcript
  579.   (lambda files
  580.     (cond ((null? files) 
  581.        (transcript-off)
  582.        novalue)
  583.       (else
  584.        (math-assert (null? (cdr files)) wna 'transcript files)
  585.        (let ((file (var->string (explicit->var (car files)))))
  586.          (transcript-on file)
  587.          (car files))))))
  588.  
  589. (defbltn 'system
  590.   (lambda (command)
  591.     (system (var->string (explicit->var command)))
  592. ;    command        ;uncomment this line if system doesn't return nicely
  593.     ))
  594.  
  595. (defbltn 'coeffs
  596.   (lambda (poly var)
  597.     (math-assert (and (expl? poly) (not (number? poly)))
  598.          "not a polynomial?" poly)
  599.     (cdr (promote (explicit->var var) poly))))
  600.  
  601. (defbltn 'poly
  602.   (lambda (var . args)
  603.     (reduce (lambda (p c) (poly_+ (poly_* p var) c))
  604.         (cond ((> (length args) 1) args)
  605.           (else
  606.            (math-assert (and (= (length args) 1) (bunch? (car args)))
  607.                 "not a bunch?" (car args))
  608.            (car args))))))
  609.  
  610. (defbltn 'diff
  611.   (lambda (exp . args)
  612.     (reduce-init diff exp (map explicit->var args))))
  613.  
  614. ;(defbltn 'partial
  615. ;  (lambda (func arg . args)
  616. ;    (math-assert (clambda? func) "not a function?" func)
  617. ;    (math-assert (> (length args) 0) "no variables?")
  618. ;    (reduce-init partial
  619. ;         (explicit->var func)
  620. ;         (explicit->var arg)
  621. ;         (map explicit->var args))))
  622.